{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  OchreLang.InlineSuper
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Inline supper-calls.
--
-- Works on intermediate syntax because we need alpha renaming.
--
--------------------------------------------------------------------------------

module OchreLang.InlineSuper
  ( 
    inlineSuper

  ) where

import qualified OchreLang.Alpha as Alpha
import OchreLang.CompilerMon
import OchreLang.Subst
import OchreLang.Syntax
import OchreLang.SyntaxBase


import Control.Applicative
import qualified Data.Map as Map



-- Don\'t initNameGen
inlineSuper :: MethodDict -> Instrument -> Compiler Instrument
inlineSuper env ins@(Instrument { instr_superclass = super
                                , instr_main       = main_expr
                                , instr_methods    = methods   }) = 
    do { main1 <- inlineExpr env super main_expr
       ; methods1 <- mapM (inlineMethodDecl env super) methods
       ; return $ ins { instr_main = main1, instr_methods= methods1 }
       }

inlineMethodDecl :: MethodDict -> Ident -> MethodDecl -> Compiler MethodDecl
inlineMethodDecl env super (MethodDecl vid (MethodDefn args expr)) = 
    (\e1 -> MethodDecl vid (MethodDefn args e1)) <$> inlineExpr env super expr


inlineExpr :: MethodDict -> Ident -> Expr -> Compiler Expr
inlineExpr _   _     (Return val)                 = return $ Return val

inlineExpr _   _     (OpCall vid vs)              = return $ OpCall vid vs

inlineExpr env super (SuperCall vid vs)           = 
    case findMethodDefn super vid env of
      Nothing -> throwError "InlineSuper.inlineExpr" "Cannot find super"
      Just (MethodDefn args body) -> do { senv <- insertsArgs args vs Map.empty
                                        ; e1   <- Alpha.alphaK_Expr =<< substArgs senv body
                                        ; inlineExpr env super e1
                                        }

inlineExpr _   _     (FunApp v vs)                = return $ FunApp v vs

inlineExpr env super (LetValue vid val e)         = 
    LetValue vid val <$> inlineExpr env super e

inlineExpr env super (LetSig1 vid e1 e2)          = 
    LetSig1 vid <$> inlineExpr env super e1 <*> inlineExpr env super e2

inlineExpr env super (LetSig2 v1 v2 e1 e2)        = 
    LetSig2 v1 v2 <$> inlineExpr env super e1 <*> inlineExpr env super e2

inlineExpr env super (LetSig3 v1 v2 v3 e1 e2)     = 
    LetSig3 v1 v2 v3 <$> inlineExpr env super e1 <*> inlineExpr env super e2

inlineExpr env super (LetSig4 v1 v2 v3 v4 e1 e2)  = 
    LetSig4 v1 v2 v3 v4 <$> inlineExpr env super e1 <*> inlineExpr env super e2

inlineExpr env super (LetTuple vs e1 e2)          = 
    LetTuple vs <$> inlineExpr env super e1 <*> inlineExpr env super e2

inlineExpr env super (LetFun v vs e1 e2)          = 
    LetFun v vs <$> inlineExpr env super e1 <*> inlineExpr env super e2

inlineExpr env super (Ifte val e1 e2)             =
    Ifte val <$> inlineExpr env super e1 <*> inlineExpr env super e2

inlineExpr env super (e1 :>> e2)                  = 
    (:>>) <$> inlineExpr env super e1 <*> inlineExpr env super e2

